home *** CD-ROM | disk | FTP | other *** search
/ ShareWare OnLine 2 / ShareWare OnLine Volume 2 (CMS Software)(1993).iso / cad / acadfont.zip / ETEXT.LSP < prev    next >
Lisp/Scheme  |  1993-02-19  |  9KB  |  296 lines
  1. ;  ETEXT - ver 3.1       June 1, 1988.
  2. ;  author: Terence Puls.
  3. ;
  4. (defun getspu ()
  5.        (setq cs (- lw 65))
  6.        (setq cz 0)
  7.    (while (<= cz cs)
  8.       (setq cg (read-line fl)) 
  9.       (setq cz (1+ cz))
  10. ))
  11. (defun getspl ()
  12.       (setq cs (- lw 97))
  13.       (setq cz 0)
  14.    (while (<= cz cs)
  15.       (setq cg (read-line fl))
  16.       (setq cz (1+ cz))
  17. ))
  18. (defun ucase ()
  19.       (setq f (/ sh 24))
  20.       (if (= l2 "A")
  21.       (setq fl (open "etext.gu0" "r"))
  22.  ) 
  23.  (if (/= nil (member l2 '("B" "D" "E" "F" "H" "I" "K" "L" "M" "N" "P" "R")))
  24.      (setq fl (open "etext.gu1" "r"))
  25.  )        
  26.   (if (/= nil (member l2 '("C" "G" "O" "Q")))
  27.       (setq fl (open "etext.gu2" "r"))
  28.  )
  29.       (if (= l2 "J")
  30.       (setq fl (open "etext.gu3" "r"))
  31.  )
  32.       (if (= l2 "S")
  33.       (setq fl (open "etext.gu4" "r"))
  34.  )
  35.       (if (= l2 "T")
  36.       (setq fl (open "etext.gu5" "r"))
  37.  )
  38.       (if (= l2 "U")
  39.       (setq fl (open "etext.gu6" "r"))
  40.  )
  41.       (if (= l2 "V")
  42.       (setq fl (open "etext.gu7" "r"))
  43.  )
  44.       (if (= l2 "W")
  45.       (setq fl (open "etext.gu8" "r"))
  46.  )
  47.       (if (= l2 "X")
  48.       (setq fl (open "etext.gu9" "r"))
  49.  )
  50.       (if (= l2 "Y")
  51.       (setq fl (open "etext.gua" "r"))
  52.  )
  53.       (if (= l2 "Z")
  54.       (setq fl (open "etext.gub" "r"))                   
  55.  )
  56. (getspu)
  57. (close fl)
  58. ; insp
  59. )
  60. (defun ulcase ()
  61.          (setq f (/ sh 24))
  62.          (if (/= nil (member l2 '("a" "c" "d" "e" "g" "o" "q")))
  63.          (setq fl (open "etext.g0" "r"))
  64.  )
  65.          (if (/= nil (member l2 '("b" "h" "i" "k" "l" "m" "n" "p" "r" "u")))
  66.          (setq fl (open "etext.g1" "r"))
  67.  )
  68.          (if (/= nil (member l2 '("f" "w")))
  69.          (setq fl (open "etext.g2" "r"))
  70.  )
  71.          (if (= l2 "j")
  72.          (setq fl (open "etext.g3" "r"))
  73.  )
  74.          (if (/= nil (member l2 '("s" "t")))
  75.          (setq fl (open "etext.g4" "r"))
  76.  )
  77.          (if (/= nil (member l2 '("v" "y")))
  78.          (setq fl (open "etext.g5" "r"))
  79.  )
  80.          (if (= l2 "x")
  81.          (setq fl (open "etext.g6" "r"))
  82.  )
  83.          (if (= l2 "z")
  84.          (setq fl (open "etext.g7" "r"))
  85.  )
  86. (getspu)
  87. (close fl)
  88. ;insp
  89. )
  90. (defun lcase ()
  91.          (setq f (/ sh 24))                 
  92.          (if (/= nil (member l2 '("a" "c" "d" "e" "g" "o" "q")))
  93.          (setq fl (open "etext.gl0" "r"))
  94.  )
  95.          (if (/= nil (member l2 '("b" "h" "i" "k" "l" "m" "n" "p" "r" "u")))
  96.          (setq fl (open "etext.gl1" "r"))
  97.  )
  98.          (if (/= nil (member l2 '("f" "w")))
  99.          (setq fl (open "etext.gl2" "r"))
  100.  )
  101.          (if (= l2 "j")
  102.          (setq fl (open "etext.gl3" "r"))
  103.  )
  104.          (if (/= nil (member l2 '("s" "t")))
  105.          (setq fl (open "etext.gl4" "r"))
  106.  )
  107.          (if (/= nil (member l2 '("v" "y")))
  108.          (setq fl (open "etext.gl5" "r"))
  109.  )
  110.          (if (= l2 "x")
  111.          (setq fl (open "etext.gl6" "r"))
  112.  )
  113.          (if (= l2 "z")
  114.          (setq fl (open "etext.gl7" "r"))
  115.  )
  116. (getspl)
  117. (close fl)
  118. )
  119. (defun gethyp ()
  120. (setq pt (list (+ (car pt) (* fr (+ (/ sh 2.0) (* dx f)))) (+ (cadr pt) 0.0)))
  121.          (setq ej (* f fr))
  122.          (command "insert" "ebk45" pt ej f 0)
  123.          (setq ct (1+ ct))
  124.      (setq pt (list (+ (car pt) (* fr (+ sh 0.0))) (+ (cadr pt) 0.0)))
  125.          (setq lw (ascii (substr ss (1+ ct) 1)))
  126.          (setq eu (strcat "EBK" (itoa lw)))
  127.          (setq ej (* fr f))
  128.          (command "insert" eu pt ej f 0)
  129.          (setq ct (1+ ct))
  130.         (if (/= (substr ss (1+ ct) 1) ".")
  131.            (setq da 1 ))
  132. )
  133. (defun getsla ()
  134. (if (or (= ro 1) (= ro 0))
  135. (setq pt (list (+ (car pt) (* fr (+ (/ sh 2.0) (* dx f)))) (+ (cadr pt) 0.0)))
  136. (setq pt (list (+ (car pt) (* fr (+ (* 4.33 f) (/ sh 2.0) (* dx f)))) (+ (cadr pt) 0.0)))
  137. )
  138.          (setq ej (* f fr))
  139.          (command "insert" "ebk47" pt ej f 0)
  140.          (setq ct (1+ ct))
  141.      (setq pt (list (+ (car pt) (* fr (+ sh 0.0))) (+ (cadr pt) 0.0)))
  142.          (setq lw (ascii (substr ss (1+ ct) 1)))
  143.          (setq eu (strcat "EBK" (itoa lw)))
  144.          (setq ej (* fr f))
  145.          (command "insert" eu pt ej f 0)
  146.          (setq ct (1+ ct))
  147.          (if (/= (substr ss (1+ ct) 1) ".")
  148.            (setq da 1))
  149. )
  150. (defun c:etext  ()
  151.        (menucmd "s=etext")
  152.        (setq wh (getstring "\n Enter series (C, D or E):"))
  153.        (setq wh (strcase wh))
  154.        (if (or (/= wh "D") (/= wh "C"))
  155.          (setq fr 1.00))
  156.        (if (= wh "D")
  157.          (setq fr 0.80))
  158.        (if (= wh "C")
  159.          (setq fr 0.66))
  160.        (setq pt (getpoint "\n Etext insertion point :"))
  161.        (princ "\ntext height-inches <")
  162.        (setq ib (open "etext.dft" "r"))
  163.        (setq sh (atof (read-line ib)))
  164.        (close ib)
  165.        (prin1 sh)
  166.        (prin1 '>)
  167.        (setq sy (getstring " :"))
  168.          (if  (= sy "")
  169.             (setq sh sh)
  170.             (setq sh (atof sy))
  171.        ) 
  172.        (setq ib (open "etext.dft" "w"))
  173.        (setq ie (rtos sh 2 2))
  174.        (write-line ie ib)
  175.        (close ib)
  176.        (setq sl (strlen (setq ss (getstring T "\n text :"))))
  177.             (setvar "cmdecho" 0)
  178.              (setq fl (open "etext.dt1" "r"))
  179.              (setq ct 0 lt nil)
  180.              (while (< ct 52)              ;read in character spaces
  181.                  (setq ld (read-line fl))
  182.                  (setq lt (cons ld lt))
  183.                  (setq ct (1+ ct))
  184.                )
  185.                  (setq lt (reverse lt))
  186.                  (setq ct 1 es (1- (strlen ss)))       
  187.                  (setq sj (substr ss 1 1))
  188.                  (close fl)
  189.      (while (< ct sl)   ;put in spaces routine
  190.  ; here should go the routine to figure out which block to insert
  191.               (setq l1 (substr ss ct 1) l2 (substr ss (1+ ct) 1))
  192.               (setq lw (ascii l1) lx (ascii l2))
  193.             (if (and (< lx 96) (= ct 1))
  194.             (progn 
  195.            (setq eu (strcat "EBK" (itoa lw)))   
  196.              (command "insert" eu pt (* fr (/ sh 24)) (/ sh 24) 0)
  197.              ))
  198.              (if (and (> lx 96) (= ct 1))
  199.             (progn
  200.              (setq eu (strcat "EBK" (itoa lw))) 
  201.               (command "insert" eu pt (* fr (/ sh 24)) (/ sh 24) 0)
  202.             ))
  203. ;*********************************
  204.        (if (and (/= 32 lx) (/= 45 lx) (/= 46 lx) (/= 47 lx))
  205.           (progn
  206.               (if (and (< lx 96) (< lw 96))
  207.                 (ucase))
  208.               (if (and (< lw 96) (> lx 96))
  209.                 (ulcase))
  210.               (if (and (> lw 96) (> lx 96))
  211.                 (lcase))
  212.               (setq cg (substr cg 2))
  213.               (setq cx (atof cg))
  214. ))
  215. ;*********************************
  216.  (if (or (= 32 lx) (= 45 lx) (= 46 lx) (= 47 lx))
  217.    (progn
  218.         (if (< lw 96)
  219.           (progn 
  220.             (setq cs (- lw 65) F (/ SH 24)) 
  221.             (setq dx (atof (substr (nth cs lt) 2)))
  222.             ))
  223.         (if (> lw 96)
  224.             (progn
  225.             (setq cs (- lw 97) F (/ SH 24))
  226.             (setq dx (atof (substr (nth (+ 26 cs) lt) 2)))
  227.             ))
  228. ))
  229. ;*********************************
  230.    (setq ro 0) ;this is the test condition T./ 1 or t./ 2 in slash routine
  231.   (if (= 46 lx)
  232.     (progn
  233.          (setq tq pt) 
  234.          (if (= l1 (car (member l1 '("Y" "W" "V" "T" "P" "F"))))
  235.       (setq tq (list (+ (car tq) (* fr (* dx f))) (+ (cadr tq) 0.0)) ro 1)
  236. (setq tq (list (+ (car tq) (* fr (+ (* 4.33 f) (* dx f)))) (+ (cadr tq) 0.0)) ro 2)
  237.          )
  238.        (command "insert" "ebk46" tq f f 0)
  239.      (if (= (substr ss (+ ct 2) 1) "-")
  240.          (progn
  241.           (setq ct (1+ ct))
  242.           (gethyp)))
  243.      (if (= (substr ss (+ ct 2) 1) "/")
  244.         (progn
  245.          (setq ct (1+ ct))
  246.          (getsla)))
  247.     (if (= (substr ss (+ ct 2) 1) "")
  248.       (progn
  249.          (setq ct (+ ct 10))))
  250.   (if (= (substr ss (+ ct 2) 1) " ")
  251.    (progn
  252.         (setq pt (list (+ (car pt) (* fr (+ sh (* dx f)))) (+ (cadr pt) 0.0)))
  253.         (setq ct (+ ct 2))
  254.         (setq lw (ascii (substr ss (1+ ct) 1)))
  255.         (setq eu (strcat "EBK" (itoa lw)))
  256.         (setq ej (* f fr))
  257.         (command "insert" eu pt ej f 0) 
  258.         (setq ct (1+ ct))
  259.          ))
  260.     ))
  261. ;*********************************
  262.  (if (= 32 lx)
  263.    (progn
  264.        (setq pt (list (+ (car pt) (* fr (+ sh (* dx f)))) (+ (cadr pt) 0.0)))
  265.        (setq ct (1+ ct))
  266.        (setq lw (ascii (substr ss (1+ ct) 1)))
  267.        (setq eu (strcat "EBK" (itoa lw)))
  268.        (setq ej (* f fr))
  269.        (command "insert" eu pt ej f 0) 
  270.        (setq ct (1+ ct))   
  271. ))
  272. ;***************************
  273.     (if (= lx 45)
  274.       (gethyp)
  275. )
  276. ;***************************
  277.     (if (= lx 47)
  278.       (getsla)
  279. )     
  280. ;***************************
  281.       (if (and (/= lx 32) (/= 45 lx) (/= lx 46) (/= lx 47) (/= da 1))
  282.         (progn
  283.               (setq cx (* cx f))
  284.               (setq pt (list (+ (car pt) (* fr cx)) (+ (cadr pt) 0.0)))
  285.               (setq eu (strcat "EBK" (itoa lx)))
  286.               (setq ej (* fr f)) 
  287.               (command "insert" eu pt ej f 0)
  288.               (setq ct (1+ ct))
  289.     )
  290. )
  291. (setq da 0)
  292. ;***************************
  293. )
  294.        (setvar "cmdecho" 1)     
  295. )     
  296.